perm filename FILLX.F4[1,LCS] blob sn#093931 filedate 1974-03-27 generic text, type T, neo UTF8
00100		IMPLICIT INTEGER(A-Z)
00150		REAL HT,DIS,Y,HX,DX,B,H
00200		COMMON Q(100),R(100),E(100),NN
00210		COMMON/LL/L
00300		DATA Q/24,50,0,24,24,42,8,24,24,32,16,24,88*0/
00400		1,R/30,0,0,30,24,4,4,24,16,8,8,16,88*0/
00500		1,E/-1,0,0,0,-1,0,0,0,-1,91*0/,TOT/12/
00600	
00700	15	NN=0
01410	200	FORMAT(A5)
01420	201	FORMAT(10I)
01430	202	FORMAT(' TYPE FILE NAME  '$)
01435		TYPE 202
01440		ACCEPT 200,NM
01450		CALL IFILE(1,NM)
01452		READ(1,201)K,K
01455		J=1
01460	204	READ(1,201,END=203)K,L,(Q(K),K=J,J+L-1)
01470		J=J+L
01480		GO TO 204
01485	203	TOT=Q(1)-1
01487		Z=5
01490	206	DO 205 K=1,J-2
01500		CALL UNPACK(K+1,M,N,Q)
01510		E(K)=0
01520		IF(L.EQ.3)E(K)=-1
01530		Q(K)=M*Z
01540	205	R(K)=N*Z
01690	400	DO 40 K=1,TOT
01695		J=2
01700		IF(E(K))J=3
01800	40	CALL LINES(Q(K),R(K),J)
01810		DO 41 K=2,TOT
01820	41	IF(Q(K).EQ.Q(K-1))E(K)=-1
01900		N=1
02000	4	J=0
02010		CALL DPYOUT(1)
02100		H=-1000
02200		Z=0
02300		DO 1 K=2,TOT
02400		IF(E(K).NE.0)GO TO 1
02500		A=R(K)+500
02600		B=R(K-1)+500
02700		IF(B.GT.A)GO TO 21
02800		C=A*1000+B
02900		GO TO 20
03000	21	C=B*1000+A
03100	20	IF(C.LE.Z)GO TO 1
03200		Z=C
03300	C  FINDS HIGHEST LINE
03400		J=K
03500		H=R(J)
03600	1	CONTINUE
03700	
03800		IF(J.EQ.0)GO TO 10
04000		JA=J-1
04100	C  J = END OF HIGHEST LINE
04200	19	RT=Q(J)
04300		LF=Q(JA)
04400		RJ=R(J)
04500		RJ1=R(JA)
04600	16	E(J)=-1
04700	C  LINE USED
04800		HT=RJ-RJ1
04900		DIS=RT-LF
05000		M=1
05100		IF(DIS)M=-M
05110		X=-1
05155		J=3
05200	
05300	17	DO 2 K=LF,RT,M
05500		Y=(HT*(K-LF))/DIS+RJ1
05610		IF(X)CALL LINES(K,IFIX(Y),J)
05620		J=2
05700		H=-1000
05800	
05900	18	DO 3 I=2,TOT
06000		IF(E(I))GO TO 3
06100	C  SKIP IF SAME LINE.
06200		QA=Q(I)
06300		QB=Q(I-1)
06400		IF((QA.GT.K.AND.QB.GT.K).OR.(QA.LT.K.AND.QB.LT.K))GOTO 3
06500	C  LINE WAS NOT UNDER POINT K
06600		RA=R(I)
06700		RB=R(I-1)
06800		HX=RA-RB
06900		DX=QA-QB
07000		B=(HX*(K-QB))/DX+RB
07100		IF(B.GT.Y)GO TO 3
07200		IF(B.LE.H)GO TO 3
07210	CC	IF((K.EQ.QA.OR.K.EQ.QB).AND.B.NE.Y)GO TO 3
07300		H=B
07400		IX=I
07500	C  FOUND HIGHEST NEW POINT
07600	3	CONTINUE
07700		IF(H.EQ.Y)GO TO 2
07800	C  WIPES OUT THIS LINE SEG.
07900	30	IF(K.NE.Q(IX).AND.K.NE.Q(IX-1))E(IX)=1
08000	C  TOUCHING END OF SEG. DOES NOT COUNT.
08100	
08200		IF(H.EQ.-1000)GO TO 2
08310		CALL LINES(K,IFIX(H),J)
08320		IF(X.GT.0)CALL LINES(K,IFIX(Y),J)
08330		X=-X
08400	CC	N=N+3
08500	2	CONTINUE
08600	
08610		GO TO 4
11705	10	CALL DPYOUT(1)
11800	14	PAUSE
11900		GO TO 15
12000		END
12100	
12200